home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / gnu / emacs / emacs1857 / src_d2.zoo / source / alloc.c < prev    next >
C/C++ Source or Header  |  1991-12-02  |  41KB  |  1,565 lines
  1. /* Storage allocation and gc for GNU Emacs Lisp interpreter.
  2.    Copyright (C) 1985, 1986 Free Software Foundation, Inc.
  3.  
  4. This file is part of GNU Emacs.
  5.  
  6. GNU Emacs is free software; you can redistribute it and/or modify
  7. it under the terms of the GNU General Public License as published by
  8. the Free Software Foundation; either version 1, or (at your option)
  9. any later version.
  10.  
  11. GNU Emacs is distributed in the hope that it will be useful,
  12. but WITHOUT ANY WARRANTY; without even the implied warranty of
  13. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14. GNU General Public License for more details.
  15.  
  16. You should have received a copy of the GNU General Public License
  17. along with GNU Emacs; see the file COPYING.  If not, write to
  18. the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  */
  19.  
  20.  
  21. #include "config.h"
  22. #include "lisp.h"
  23. #ifndef standalone
  24. #include "buffer.h"
  25. #include "window.h"
  26. #endif
  27.  
  28. #define max(A,B) ((A) > (B) ? (A) : (B))
  29.  
  30. /* Macro to verify that storage intended for Lisp objects is not
  31.    out of range to fit in the space for a pointer.
  32.    ADDRESS is the start of the block, and SIZE
  33.    is the amount of space within which objects can start.  */
  34. #define VALIDATE_LISP_STORAGE(address, size)            \
  35. do                                \
  36.   {                                \
  37.     Lisp_Object val;                        \
  38.     XSET (val, Lisp_Cons, (char *) address + size);        \
  39.     if ((char *) XCONS (val) != (char *) address + size)    \
  40.       {                                \
  41.     free (address);                        \
  42.     memory_full ();                        \
  43.       }                                \
  44.   } while (0)
  45.  
  46. /* Number of bytes of consing done since the last gc */
  47. int consing_since_gc;
  48.  
  49. /* Number of bytes of consing since gc before another gc should be done. */
  50. int gc_cons_threshold;
  51.  
  52. /* value of consing_since_gc when undos were last truncated.  */
  53. int consing_at_last_truncate;
  54.  
  55. /* Nonzero during gc */
  56. int gc_in_progress;
  57.  
  58. #ifndef VIRT_ADDR_VARIES
  59. extern
  60. #endif /* VIRT_ADDR_VARIES */
  61.  int malloc_sbrk_used;
  62.  
  63. #ifndef VIRT_ADDR_VARIES
  64. extern
  65. #endif /* VIRT_ADDR_VARIES */
  66.  int malloc_sbrk_unused;
  67.  
  68. /* Two thresholds controlling how much undo information to keep.  */
  69. int undo_threshold;
  70. int undo_high_threshold;
  71.  
  72. /* Non-nil means defun should do purecopy on the function definition */
  73. Lisp_Object Vpurify_flag;
  74.  
  75. /* Argument we give to Fsignal when memory is full.
  76.    Preallocated since perhaps we can't allocate it when memory is full.  */
  77. Lisp_Object memory_exhausted_message;
  78.  
  79. #ifndef HAVE_SHM
  80. int pure[PURESIZE / sizeof (int)] = {0,};   /* Force it into data space! */
  81. #define PUREBEG (char *) pure
  82. #else
  83. #define pure PURE_SEG_BITS   /* Use shared memory segment */
  84. #define PUREBEG (char *)PURE_SEG_BITS
  85. #endif /* not HAVE_SHM */
  86.  
  87. /* Index in pure at which next pure object will be allocated. */
  88. int pureptr;
  89.  
  90. /* If nonzero, this is a warning delivered by malloc and not yet displayed.  */
  91. char *pending_malloc_warning;
  92.  
  93. Lisp_Object
  94. malloc_warning_1 (str)
  95.      Lisp_Object str;
  96. {
  97.   Fprinc (str, Vstandard_output);
  98.   write_string ("\nKilling some buffers may delay running out of memory.\n", -1);
  99.   write_string ("However, certainly by the time you receive the 95% warning,\n", -1);
  100.   write_string ("you should clean up, kill this Emacs, and start a new one.", -1);
  101.   return Qnil;
  102. }
  103.  
  104. /* malloc calls this if it finds we are near exhausting storage */
  105. malloc_warning (str)
  106.      char *str;
  107. {
  108.   pending_malloc_warning = str;
  109. }
  110.  
  111. display_malloc_warning ()
  112. {
  113.   register Lisp_Object val;
  114.  
  115.   val = build_string (pending_malloc_warning);
  116.   pending_malloc_warning = 0;
  117.   internal_with_output_to_temp_buffer (" *Danger*", malloc_warning_1, val);
  118. }
  119.  
  120. /* Called if malloc returns zero */
  121. memory_full ()
  122. {
  123.   while (1)
  124.     Fsignal (Qerror, memory_exhausted_message);
  125. }
  126.  
  127. /* like malloc and realloc but check for no memory left */
  128.  
  129. long *
  130. xmalloc (size)
  131.      int size;
  132. {
  133.   register long *val;
  134.   /* Avoid failure if malloc (0) returns 0.  */
  135.   if (size == 0)
  136.     size = 1;
  137.   val = (long *) malloc (size);
  138.   if (!val) memory_full ();
  139.   return val;
  140. }
  141.  
  142. long *
  143. xrealloc (block, size)
  144.      long *block;
  145.      int size;
  146. {
  147.   register long *val;
  148.   /* Avoid failure if malloc (0) returns 0.  */
  149.   if (size == 0)
  150.     size = 1;
  151.   val = (long *) realloc (block, size);
  152.   if (!val) memory_full ();
  153.   return val;
  154. }
  155.  
  156. /* Allocation of cons cells */
  157. /* We store cons cells inside of cons_blocks, allocating a new
  158.  cons_block with malloc whenever necessary.  Cons cells reclaimed by
  159.  GC are put on a free list to be reallocated before allocating
  160.  any new cons cells from the latest cons_block.
  161.  
  162.  Each cons_block is just under 1016 bytes long,
  163.  since malloc really allocates in units of powers of two
  164.  and uses 8 bytes for its own overhead. */
  165.  
  166. #define CONS_BLOCK_SIZE \
  167.   ((1016 - sizeof (struct cons_block *)) / sizeof (struct Lisp_Cons))
  168.  
  169. struct cons_block
  170.   {
  171.     struct cons_block *next;
  172.     struct Lisp_Cons conses[CONS_BLOCK_SIZE];
  173.   };
  174.  
  175. struct cons_block *cons_block;
  176. int cons_block_index;
  177.  
  178. struct Lisp_Cons *cons_free_list;
  179.  
  180. void
  181. init_cons ()
  182. {
  183.   cons_block = (struct cons_block *) malloc (sizeof (struct cons_block));
  184.   cons_block->next = 0;
  185.   bzero (cons_block->conses, sizeof cons_block->conses);
  186.   cons_block_index = 0;
  187.   cons_free_list = 0;
  188. }
  189.  
  190. /* Explicitly free a cons cell.  */
  191. free_cons (ptr)
  192.      struct Lisp_Cons *ptr;
  193. {
  194.   XFASTINT (ptr->car) = (int) cons_free_list;
  195.   cons_free_list = ptr;
  196. }
  197.  
  198. DEFUN ("cons", Fcons, Scons, 2, 2, 0,
  199.   "Create a new cons, give it CAR and CDR as components, and return it.")
  200.   (car, cdr)
  201.      Lisp_Object car, cdr;
  202. {
  203.   register Lisp_Object val;
  204.  
  205.   if (cons_free_list)
  206.     {
  207.       XSET (val, Lisp_Cons, cons_free_list);
  208.       cons_free_list = (struct Lisp_Cons *) XFASTINT (cons_free_list->car);
  209.     }
  210.   else
  211.     {
  212.       if (cons_block_index == CONS_BLOCK_SIZE)
  213.     {
  214.       register struct cons_block *new = (struct cons_block *) malloc (sizeof (struct cons_block));
  215.       if (!new) memory_full ();
  216.       VALIDATE_LISP_STORAGE (new, sizeof *new);
  217.       new->next = cons_block;
  218.       cons_block = new;
  219.       cons_block_index = 0;
  220.       XSET (val, Lisp_Cons, &cons_block->conses[CONS_BLOCK_SIZE - 1]);
  221.     }
  222.       XSET (val, Lisp_Cons, &cons_block->conses[cons_block_index++]);
  223.     }
  224.   XCONS (val)->car = car;
  225.   XCONS (val)->cdr = cdr;
  226.   consing_since_gc += sizeof (struct Lisp_Cons);
  227.   return val;
  228. }
  229.  
  230. DEFUN ("list", Flist, Slist, 0, MANY, 0,
  231.   "Return a newly created list whose elements are the arguments (any number).")
  232.   (nargs, args)
  233.      int nargs;
  234.      register Lisp_Object *args;
  235. {
  236.   register Lisp_Object len, val, val_tail;
  237.  
  238.   XFASTINT (len) = nargs;
  239.   val = Fmake_list (len, Qnil);
  240.   val_tail = val;
  241.   while (!NULL (val_tail))
  242.     {
  243.       XCONS (val_tail)->car = *args++;
  244.       val_tail = XCONS (val_tail)->cdr;
  245.     }
  246.   return val;
  247. }
  248.  
  249. DEFUN ("make-list", Fmake_list, Smake_list, 2, 2, 0,
  250.   "Return a newly created list of length LENGTH, with each element being INIT.")
  251.   (length, init)
  252.      register Lisp_Object length, init;
  253. {
  254.   register Lisp_Object val;
  255.   register int size;
  256.  
  257.   if (XTYPE (length) != Lisp_Int || XINT (length) < 0)
  258.     length = wrong_type_argument (Qnatnump, length);
  259.   size = XINT (length);
  260.  
  261.   val = Qnil;
  262.   while (size-- > 0)
  263.     val = Fcons (init, val);
  264.   return val;
  265. }
  266.  
  267. /* Allocation of vectors */
  268.  
  269. struct Lisp_Vector *all_vectors;
  270.  
  271. DEFUN ("make-vector", Fmake_vector, Smake_vector, 2, 2, 0,
  272.   "Return a newly created vector of length LENGTH, with each element being INIT.")
  273.   (length, init)
  274.      register Lisp_Object length, init;
  275. {
  276.   register int sizei, index;
  277.   register Lisp_Object vector;
  278.   register struct Lisp_Vector *p;
  279.  
  280.   if (XTYPE (length) != Lisp_Int || XINT (length) < 0)
  281.     length = wrong_type_argument (Qnatnump, length);
  282.   sizei = XINT (length);
  283.  
  284.   p = (struct Lisp_Vector *) malloc (sizeof (struct Lisp_Vector) + (sizei - 1) * sizeof (Lisp_Object));
  285.   if (p == 0)
  286.     memory_full ();
  287.   VALIDATE_LISP_STORAGE (p, 0);
  288.  
  289.   XSET (vector, Lisp_Vector, p);
  290.   consing_since_gc += sizeof (struct Lisp_Vector) + (sizei - 1) * sizeof (Lisp_Object);
  291.  
  292.   p->size = sizei;
  293.   p->next = all_vectors;
  294.   all_vectors = p;
  295.  
  296.   for (index = 0; index < sizei; index++)
  297.     p->contents[index] = init;
  298.  
  299.   return vector;
  300. }
  301.  
  302. DEFUN ("vector", Fvector, Svector, 0, MANY, 0,
  303.   "Return a newly created vector with our arguments (any number) as its elements.")
  304.   (nargs, args)
  305.      register int na